Delphi 2.0 - Programmer's Utilities Power Pack/Delphi 2.0 Programmer's Utilities Power Pack.iso/s_to_z/tpack/tblretry.pas

Pascal/Delphi Source File | 1996-09-15 | 8.7 KB | 324 lines

unit TblRetry;
{provides the core table type with retryability for open/edits, plus a pack command
stolen from somewhere, as well as a scan callback feature.}

{I could not resist including it in this package as it demonstrates the power of
the retry concept (code for sale) so well. I'm specializing in database apps so I
didn't really give you the works here; that would be another project; but while the
purpose here is to get you to understand the retry idea there are some other concept
buried in this code. enjoy.}

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, DB, DBGrids, dbTables, StdCtrls
, Debug
, PasUtils
, Xtension
, ErrorMsg
, Retry;

type

  TTableExtendedType = class(TTable)
    cx: TComponentExtensions;
  private
  public
    Constructor Create(aOwner:TComponent); Override;
    Destructor Destroy; Override;
    procedure Loaded; Override;
  published
  end;

  TTableWithRetry = class;
  TTableCoreNotifyEvent = procedure(Sender:TTableWithRetry) of object;

  TTableWithRetry = class(TTableExtendedType)
  private
    { Private declarations }
    fRetry: TRetry;
    fPostBeforeClose: Boolean; {will try to post before closing if true}
    fHideLinking: Boolean; {will disable linking fields on open.. does not turn on any}
    fWasOpen:Boolean;      {table was open when loaded/last 'retry..'d.}
    fLeaveOpen:Boolean;    {leave table open after first use.}
    fOnScan: TTableCoreNotifyEvent; {called for every record during a scan}
    fOnRetryException: TRetryExceptionEvent;
  protected
    { Protected declarations }
    procedure DoAfterOpen; Override;
    procedure DoBeforeClose; Override;
    procedure DoBeforePost; Override;
    procedure DoOnNewRecord; Override;
    procedure DoRetryOpen(Sender:TObject);
    procedure DoRetryEdit(Sender:TObject);
    procedure RetryException(Sender:TObject;E:Exception;var Action:TExceptionReAction); Virtual;
    function  GetTableFullName:String;
    procedure SetTableFullName(const Value:String);
  public
    { Public declarations }
    constructor Create(AOwner:TComponent); Override;
    destructor Destroy; Override;
    procedure Loaded; Override;
    procedure RetryOpen;
    procedure RetryEdit;
    procedure MayClose;
    procedure Scan;
    procedure Pack;
  published
    { Published declarations }
    property TableFullName: String read GetTableFullName write SetTableFullName stored False;
    property Retry: TRetry read fRetry write fRetry;
    property PostBeforeClose: Boolean read fPostBeforeClose write fPostBeforeClose;
    property HideLinkingKeys: Boolean read fHideLinking write fHideLinking;
    property WasOpen: Boolean  read fWasOpen  write fWasOpen stored false;
    property LeaveOpen: Boolean  read fLeaveOpen  write fLeaveOpen;
    property OnScan: TTableCoreNotifyEvent  read fOnScan  write fOnScan;
    property OnRetryException: TRetryExceptionEvent read fOnRetryException write fOnRetryException;
    end;

implementation

uses
  dbiprocs
  ,dbitypes
  ,dbierrs;

{------------------------------------------------------------------------------}
{                                                                              }
{------------------------------------------------------------------------------}

Constructor TTableExtendedType.Create(aOwner:TComponent);
begin
  if (decCreate in DebugFlags) then
    DebugLog(aOwner,'Create '+ClassName+' ('+aOwner.Name+':'+aOwner.ClassName+')');
  inherited Create(aOwner);
  cx:= TComponentExtensions.Create(Self);
end;

Destructor TTableExtendedType.Destroy;
begin
  if (decDestroy in DebugFlags) then
    DebugLog(Owner,'Destroy '+ClassName);
  cx.Free;
  inherited Destroy;
end;

procedure TTableExtendedType.Loaded;
begin
  if (decLoaded in DebugFlags) then
    DebugLog(Owner,'Loaded '+ClassName);
  inherited Loaded;
end;

{------------------------------------------------------------------------------}
{                                                                              }
{------------------------------------------------------------------------------}

constructor TTableWithRetry.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  fRetry:=TRetry.Create;
  with fRetry do begin
    Interval.Interval:=200;
    Interval.RandomTime:=200;
    OnException:=RetryException;
    end;
end;

destructor TTableWithRetry.Destroy;
begin
  fRetry.Free;
  inherited Destroy;
end;

procedure TTableWithRetry.Loaded;
begin
  inherited Loaded;
  fWasOpen:=Active;
end;

procedure TTableWithRetry.MayClose;
begin
  if (not fWasOpen) or (not fLeaveOpen) then begin
    Close;
    fWasOpen:=Active;
    end;
end;

function TTableWithRetry.GetTableFullName:String;
begin
  Result:=TrailingBackSlash(DatabaseName)+TableName;
end;

procedure TTableWithRetry.SetTableFullName(const Value:String);
begin
  Active:=False;
  DatabaseName:=ExtractFilePath(Value);
  TableName:=ExtractFileName(Value);
end;

{---------------------------------------------------------------------------}

procedure TTableWithRetry.RetryException(Sender:TObject;E:Exception;var Action:TExceptionReAction);
begin
  if assigned(fOnRetryException) then
    fOnRetryException(Self,E,Action);
end;

procedure TTableWithRetry.RetryOpen;
begin
  if not Active then
    fRetry.RetryAction(DoRetryOpen);
end;
{}
procedure TTableWithRetry.DoRetryOpen(Sender:TObject);
begin
  if not Active then
    Open;
end;

procedure TTableWithRetry.RetryEdit;
begin
  if not (State in dsEditModes) then
    fRetry.RetryAction(DoRetryEdit);
end;
{}
procedure TTableWithRetry.DoRetryEdit(Sender:TObject);
begin
  if State<>dsEdit then
    Edit;
end;

{---------------------------------------------------------------------------}

procedure TTableWithRetry.DoBeforeClose;
begin
  if fPostBeforeClose then
    if State in dsEditModes then
      Post;
  inherited DoBeforeClose;
end;

procedure TTableWithRetry.DoAfterOpen;
var
  n:integer;
  a0,a:string;
begin
  inherited DoAfterOpen;
  if fHideLinking then begin
    {hide linking columns}
    a0:=MasterFields+';';
    n:=-1;
    repeat
      SplitString(a0,';',a,a0);
      if a<>'' then begin
        inc(n);
        IndexFields[n].Visible:=False;
        end;
    until a0='';
    end;
end;

procedure TTableWithRetry.DoOnNewRecord;
{var
  n:integer;
  a0,a:string;}
begin
  inherited DoOnNewRecord;
  {insert linking values}
{  a0:=MasterFields+';';
  n:=-1;
  repeat
    SplitString(a0,';',a,a0);
    if a<>'' then begin
      inc(n);
      IndexFields[n].Text:=MasterSource.DataSet.FieldByName(a).AsString;
      end;
  until a0='';}
end;

procedure TTableWithRetry.DoBeforePost;
begin
  inherited DoBeforePost;
end;

{------------------------------------------------------------------------------}
{                                                                              }
{------------------------------------------------------------------------------}

procedure TTableWithRetry.Scan;
begin
  try
    RetryOpen;
    First;
    while not eof do begin
      if assigned(fOnScan) then
        fOnScan(Self);
      Next;
      end;
  finally
    MayClose;
    end;
end;

{---------------------------------------------------------------------------}

procedure TTableWithRetry.Pack;
var
  rslt: DBIResult;
  szErrMsg: DBIMSG;
  pTblDesc: pCRTblDesc;
  bExclusive: Boolean;
  bActive: Boolean;
begin
  {save state}
  bExclusive:=Exclusive;
  bActive:=Active;
  DisableControls;
  Close;
  {begin operation}
  Exclusive := TRUE;
  case TableType of
  ttdBASE: begin
    Open;
    rslt := DbiPackTable( DBHandle, Handle, nil, nil, TRUE);
    if rslt <> DBIERR_NONE then begin
      DbiGetErrorString( rslt, szErrMsg );
      MessageDlg( szErrMsg, mtError, [mbOk], 0 );
      end;
    end;
  ttParadox:
    if MaxAvail < SizeOf(CRTblDesc) then
      MessageDlg('Cannot pack table. Insufficient memory', mtError, [mbOk], 0 )
    else begin
      GetMem(pTblDesc, SizeOf(CRTblDesc) );
      FillChar(pTblDesc^, SizeOf(CRTblDesc), 0 );
      with pTblDesc^ do begin
        StrPCopy(szTblName, TableName );
        StrPCopy(szTblType, szParadox );
        bPack:= TRUE;
        end;
      rslt:= DbiDoRestructure(DBHandle, 1, pTblDesc, nil, nil, nil, FALSE);
      if rslt<>DBIERR_NONE then begin
        DbiGetErrorString(rslt, szErrMsg );
        MessageDlg(szErrMsg, mtError, [mbOk], 0 );
        end;
      FreeMem(pTblDesc, SizeOf(CRTblDesc) );
      end;
  else
    MessageDlg('Cannot pack this table type', mtError, [mbOk], 0 );
    end;
  {restore state}
  Close;
  Exclusive := bExclusive;
  Active := bActive;
  EnableControls;
end;


end.